home *** CD-ROM | disk | FTP | other *** search
/ Fritz: All Fritz / All Fritz.zip / All Fritz / FILES / PROGMISC / XLISP.LZH / XLISPSRC.ARC / XLFIO.C < prev    next >
Text File  |  1986-05-17  |  7KB  |  313 lines
  1. /* xlfio.c - xlisp file i/o */
  2. /*    Copyright (c) 1985, by David Michael Betz
  3.     All Rights Reserved
  4.     Permission is granted for unrestricted non-commercial use    */
  5.  
  6. #include "xlisp.h"
  7.  
  8. #ifdef MEGAMAX
  9. overlay "io"
  10. #endif
  11.  
  12. /* external variables */
  13. extern NODE *s_stdin,*s_stdout,*true;
  14. extern int xlfsize;
  15. extern char buf[];
  16.  
  17. /* external routines */
  18. extern FILE *fopen();
  19.  
  20. /* forward declarations */
  21. FORWARD NODE *printit();
  22. FORWARD NODE *flatsize();
  23. FORWARD NODE *openit();
  24.  
  25. /* xread - read an expression */
  26. NODE *xread(args)
  27.   NODE *args;
  28. {
  29.     NODE *fptr,*eof,*rflag,*val;
  30.  
  31.     /* get file pointer and eof value */
  32.     fptr = (args ? xlgetfile(&args) : getvalue(s_stdin));
  33.     eof = (args ? xlarg(&args) : NIL);
  34.     rflag = (args ? xlarg(&args) : NIL);
  35.     xllastarg(args);
  36.  
  37.     /* read an expression */
  38.     if (!xlread(fptr,&val,rflag != NIL))
  39.     val = eof;
  40.  
  41.     /* return the expression */
  42.     return (val);
  43. }
  44.  
  45. /* xprint - built-in function 'print' */
  46. NODE *xprint(args)
  47.   NODE *args;
  48. {
  49.     return (printit(args,TRUE,TRUE));
  50. }
  51.  
  52. /* xprin1 - built-in function 'prin1' */
  53. NODE *xprin1(args)
  54.   NODE *args;
  55. {
  56.     return (printit(args,TRUE,FALSE));
  57. }
  58.  
  59. /* xprinc - built-in function princ */
  60. NODE *xprinc(args)
  61.   NODE *args;
  62. {
  63.     return (printit(args,FALSE,FALSE));
  64. }
  65.  
  66. /* xterpri - terminate the current print line */
  67. NODE *xterpri(args)
  68.   NODE *args;
  69. {
  70.     NODE *fptr;
  71.  
  72.     /* get file pointer */
  73.     fptr = (args ? xlgetfile(&args) : getvalue(s_stdout));
  74.     xllastarg(args);
  75.  
  76.     /* terminate the print line and return nil */
  77.     xlterpri(fptr);
  78.     return (NIL);
  79. }
  80.  
  81. /* printit - common print function */
  82. LOCAL NODE *printit(args,pflag,tflag)
  83.   NODE *args; int pflag,tflag;
  84. {
  85.     NODE *fptr,*val;
  86.  
  87.     /* get expression to print and file pointer */
  88.     val = xlarg(&args);
  89.     fptr = (args ? xlgetfile(&args) : getvalue(s_stdout));
  90.     xllastarg(args);
  91.  
  92.     /* print the value */
  93.     xlprint(fptr,val,pflag);
  94.  
  95.     /* terminate the print line if necessary */
  96.     if (tflag)
  97.     xlterpri(fptr);
  98.  
  99.     /* return the result */
  100.     return (val);
  101. }
  102.  
  103. /* xflatsize - compute the size of a printed representation using prin1 */
  104. NODE *xflatsize(args)
  105.   NODE *args;
  106. {
  107.     return (flatsize(args,TRUE));
  108. }
  109.  
  110. /* xflatc - compute the size of a printed representation using princ */
  111. NODE *xflatc(args)
  112.   NODE *args;
  113. {
  114.     return (flatsize(args,FALSE));
  115. }
  116.  
  117. /* flatsize - compute the size of a printed expression */
  118. LOCAL NODE *flatsize(args,pflag)
  119.   NODE *args; int pflag;
  120. {
  121.     NODE *val;
  122.  
  123.     /* get the expression */
  124.     val = xlarg(&args);
  125.     xllastarg(args);
  126.  
  127.     /* print the value to compute its size */
  128.     xlfsize = 0;
  129.     xlprint(NIL,val,pflag);
  130.  
  131.     /* return the length of the expression */
  132.     return (cvfixnum((FIXNUM)xlfsize));
  133. }
  134.  
  135. /* xopeni - open an input file */
  136. NODE *xopeni(args)
  137.   NODE *args;
  138. {
  139.     return (openit(args,"r"));
  140. }
  141.  
  142. /* xopeno - open an output file */
  143. NODE *xopeno(args)
  144.   NODE *args;
  145. {
  146.     return (openit(args,"w"));
  147. }
  148.  
  149. /* openit - common file open routine */
  150. LOCAL NODE *openit(args,mode)
  151.   NODE *args; char *mode;
  152. {
  153.     NODE *fname,*val;
  154.     char *name;
  155.     FILE *fp;
  156.  
  157.     /* get the file name */
  158.     fname = xlarg(&args);
  159.     xllastarg(args);
  160.  
  161.     /* get the name string */
  162.     if (symbolp(fname))
  163.     name = getstring(getpname(fname));
  164.     else if (stringp(fname))
  165.     name = getstring(fname);
  166.     else
  167.     xlerror("bad argument type",fname);
  168.  
  169.     /* try to open the file */
  170.     if ((fp = fopen(name,mode)) != NULL)
  171.     val = cvfile(fp);
  172.     else
  173.     val = NIL;
  174.  
  175.     /* return the file pointer */
  176.     return (val);
  177. }
  178.  
  179. /* xclose - close a file */
  180. NODE *xclose(args)
  181.   NODE *args;
  182. {
  183.     NODE *fptr;
  184.  
  185.     /* get file pointer */
  186.     fptr = xlmatch(FPTR,&args);
  187.     xllastarg(args);
  188.  
  189.     /* make sure the file exists */
  190.     if (getfile(fptr) == NULL)
  191.     xlfail("file not open");
  192.  
  193.     /* close the file */
  194.     fclose(getfile(fptr));
  195.     setfile(fptr,NULL);
  196.  
  197.     /* return nil */
  198.     return (NIL);
  199. }
  200.  
  201. /* xrdchar - read a character from a file */
  202. NODE *xrdchar(args)
  203.   NODE *args;
  204. {
  205.     NODE *fptr;
  206.     int ch;
  207.  
  208.     /* get file pointer */
  209.     fptr = (args ? xlgetfile(&args) : getvalue(s_stdin));
  210.     xllastarg(args);
  211.  
  212.     /* get character and check for eof */
  213.     return ((ch = xlgetc(fptr)) == EOF ? NIL : cvfixnum((FIXNUM)ch));
  214. }
  215.  
  216. /* xpkchar - peek at a character from a file */
  217. NODE *xpkchar(args)
  218.   NODE *args;
  219. {
  220.     NODE *flag,*fptr;
  221.     int ch;
  222.  
  223.     /* peek flag and get file pointer */
  224.     flag = (args ? xlarg(&args) : NIL);
  225.     fptr = (args ? xlgetfile(&args) : getvalue(s_stdin));
  226.     xllastarg(args);
  227.  
  228.     /* skip leading white space and get a character */
  229.     if (flag)
  230.     while ((ch = xlpeek(fptr)) != EOF && isspace(ch))
  231.         xlgetc(fptr);
  232.     else
  233.     ch = xlpeek(fptr);
  234.  
  235.     /* return the character */
  236.     return (ch == EOF ? NIL : cvfixnum((FIXNUM)ch));
  237. }
  238.  
  239. /* xwrchar - write a character to a file */
  240. NODE *xwrchar(args)
  241.   NODE *args;
  242. {
  243.     NODE *fptr,*chr;
  244.  
  245.     /* get the character and file pointer */
  246.     chr = xlmatch(INT,&args);
  247.     fptr = (args ? xlgetfile(&args) : getvalue(s_stdout));
  248.     xllastarg(args);
  249.  
  250.     /* put character to the file */
  251.     xlputc(fptr,(int)getfixnum(chr));
  252.  
  253.     /* return the character */
  254.     return (chr);
  255. }
  256.  
  257. /* xreadline - read a line from a file */
  258. NODE *xreadline(args)
  259.   NODE *args;
  260. {
  261.     NODE ***oldstk,*fptr,*str,*newstr;
  262.     int len,blen,ch;
  263.     char *p,*sptr;
  264.  
  265.     /* create a new stack frame */
  266.     oldstk = xlstack;
  267.     xlsave1(str);
  268.  
  269.     /* get file pointer */
  270.     fptr = (args ? xlgetfile(&args) : getvalue(s_stdin));
  271.     xllastarg(args);
  272.  
  273.     /* get character and check for eof */
  274.     len = blen = 0; p = buf;
  275.     while ((ch = xlgetc(fptr)) != EOF && ch != '\n') {
  276.  
  277.     /* check for buffer overflow */
  278.     if (blen >= STRMAX) {
  279.          newstr = newstring(len+STRMAX);
  280.         sptr = getstring(newstr); *sptr = 0;
  281.         if (str) strcat(sptr,getstring(str));
  282.         *p = 0; strcat(sptr,buf);
  283.         p = buf; blen = 0;
  284.         len += STRMAX;
  285.         str = newstr;
  286.     }
  287.  
  288.     /* store the character */
  289.     *p++ = ch; blen++;
  290.     }
  291.  
  292.     /* check for end of file */
  293.     if (len == 0 && p == buf && ch == EOF) {
  294.     xlstack = oldstk;
  295.     return (NIL);
  296.     }
  297.  
  298.     /* append the last substring */
  299.     if (str == NIL || blen) {
  300.     newstr = newstring(len+blen);
  301.     sptr = getstring(newstr); *sptr = 0;
  302.     if (str) strcat(sptr,getstring(str));
  303.     *p = 0; strcat(sptr,buf);
  304.     str = newstr;
  305.     }
  306.  
  307.     /* restore the previous stack frame */
  308.     xlstack = oldstk;
  309.  
  310.     /* return the string */
  311.     return (str);
  312. }
  313.